Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/PBLIB1/UNITS/MISCPARS.INC

Text File | 1994-02-17 | 12KB | 463 lines

const Numerics      = [ '0'..'9','.','+','-' ];
const Alphas        = [ 'A'..'Z','a'..'z' ];
const AlphaNumerics = Alphas + Numerics;



{SECTION  CleanUpBlanks }
Procedure CleanUpBlanks(var s : string);
var done : boolean;
    stringhold : string;
     begin
     Trim(s);
     TokenizeStrings(s,stringhold);
     RemoveExcessBlanks(s);
     if stringhold > '' then DeTokenizeStrings(s,stringhold);
     end;


{SECTION  CleanUpComments }
Procedure CleanUpComments(var s : string);
{ get rid of excess blanks to prepare for parsing }
var done : boolean;
     begin
     RemoveEOLComments(s,commenteolchar);
     done := false;
     while not done do
          done := RemoveBracketComments(s,commentpairLchar,commentpairRchar);
     end;


{SECTION  CleanUpString }
Procedure CleanUpString(var s : string);
{ clean out comments and excess blanks to prepare for parsing }
     begin
     CleanUpComments(s);
     CleanUpBlanks(s);
     end;


{SECTION DeQuoteString  }
Function DeQuoteString(s : string) : string;
var s1 : string;
     begin
     s1 := s;
     if s1[1] = quotechar then delete(s1,1,1);
     if s1[length(s1)] = quotechar then delete(s1,length(s1),1);
     DeQuoteString := s1;
     end;


{SECTION  DeTokenizeStrings }
Procedure DeTokenizeStrings(var s,hold : string);
var i,j : integer;
    dummy : boolean;
    s2  : string;
     begin
     i := 1;
     while i > 0 do
         begin
         i := pos(qstringtoken,s);
         if i > 0 then
              begin
              s2 := '';
             { s[i] := '#'; }
              delete(s,i,1);
              dummy := ReplaceStringWithToken(hold,s2,qstringtoken);
              insert(s2,s,i);
              s2 := '';
              end;
         end;
     end;


{SECTION  GETAlphaNumericStr }
Function  GETAlphaNumericStr ( var s : string) : string;
var s1 : string;
    i  : integer;
     begin
     s1 := '';
     while (length(s) > 0) and not (s[1] in AlphaNumerics) do delete(s,1,1);
     while (length(s) > 0) and     (s[1] in AlphaNumerics) do
          begin
          s1 := s1 + s[1];
          delete(s,1,1);
          end;
     GETAlphaNumericStr := s1;
     end;


{SECTION  GETAlphaStr }
Function  GETAlphaStr ( var s : string) : string;
var s1 : string;
    i  : integer;
     begin
     s1 := '';
     while (length(s) > 0) and not (s[1] in Alphas) do delete(s,1,1);
     while (length(s) > 0) and     (s[1] in Alphas ) do
          begin
          s1 := s1 + s[1];
          delete(s,1,1);
          end;
     GETAlphaStr := s1;
     end;



{SECTION  GETBoolean }
Function  GETBoolean (var s : string) : boolean;
var x : boolean;
    s1 : string;
    code : integer;
     begin
     x := true;
     s1 := UpCaseStr(GetAlphaStr(s));
     if (s1 = 'NO') or (s1 = 'OFF') then x := false;
     GETBoolean := x;
     end;


{SECTION  GetDelimitedStr }
Function  GETDelimitedStr ( var s : string; lchr,rchr : char) : string;
             {[STRING] Removes string in paired brackets, l & r CAN be same}
var s1   : string;
    i,j,l  : integer;
     begin
     s1 := '';
     i := lscan(s,lchr);
     if (i > 0) then
          begin
          j := rscan(s,rchr);
          if j > i then
               begin
               l := (j - i) - 1;
               if (j > i) then
                    begin
                    if (l > 0) then s1 := copy(s,i+1,l);
                    delete(s,i,(j-i+1));
                    end;
               end;
          end;
     GETDelimitedStr := trimstr(s1);
     end;





{SECTION  GETInteger }
Function  GETInteger (var s : string) : integer;
var x : integer;
    s1 : string;
    code : integer;
     begin
     x := 0;
     s1 := GetNumericStr(s);
     val(s1,x,code);
     GETInteger := x;
     end;


{SECTION  GetLeftStr }
Function  GetLeftStr ( var s : string; tch : char) : string;
{ Note, if char not there, returns WHOLE string }
var s1 : string;
    i,l     : integer;
     begin
     trim(s);
     i := pos(tch,s);
     if i > 0 then
          begin
          s1 := copy(s,1,i-1);
          delete(s,1,i);
          end
     else begin
          s1 := s;
          s := '';
          end;
     GetLeftStr := trimstr(s1);
     end;


{SECTION  GETLongInt }
Function  GETLongInt (var s : string) : longint;
var x : longint;
    s1 : string;
    code : integer;
     begin
     x := 0;
     s1 := GetNumericStr(s);
     val(s1,x,code);
     GETLongInt := x;
     end;


{SECTION  GETNumericStr }
Function  GETNumericStr ( var s : string) : string;
var s1 : string;
    i  : integer;
     begin
     s1 := '';
     while (length(s) > 0) and not (s[1] in Numerics) do delete(s,1,1);
     while (length(s) > 0) and     (s[1] in Numerics) do
          begin
          s1 := s1 + s[1];
          delete(s,1,1);
          end;
     GETNumericStr := s1;
     end;


{SECTION  GETReal }
Function  GETReal (var s : string) : real;
var x : real;
    s1 : string;
    code : integer;
     begin
     x := 0;
     s1 := GetNumericStr(s);
     val(s1,x,code);
     GETReal := x;
     end;


{SECTION  GetRightStr }
Function  GetRightStr ( var s : string; tch : char) : string;
{ Note, if char not there, returns EMPTY string }
var s1 : string;
    i,l     : integer;
     begin
     s1 := trimstr(s);
     i := rscan(s1,tch);
     if i > 0 then
          begin
          s := copy(s1,1,i-1);
          delete(s1,1,i);
          end
     else begin
          s1 := '';
          end;
     GetRightStr := trimstr(s1);
     end;




{SECTION LScan  }
Function LScan(str : string; tch : char) : byte;
      {[STRING] finds FIRST occurance of char TCH in string STR }
var i,j : integer;
     begin
     j := 0;
     i := 0;
     while (i < length(str)) and (j = 0) do
          begin
          inc(i);
          if str[i] = tch then j := i;
          end;
     LScan := j;
     end;


{SECTION  NibbleString  }
Function  NibbleString(var s : string;tch : termchars; var termch : char) : string;
           {[STRING] fetches to one of a SET of chars - see also GetLeftStr }
var dummy, done : boolean;
    i     : integer;
    stringhold,s1 : string;
     begin
     termch := '%';
     s1 := '';
     RemoveLeading(s,' ');
     TokenizeStrings(s,stringhold);
     if s[1] = qstringtoken then
          begin
          dummy := ReplaceStringWithToken(stringhold,s1,qstringtoken);
          delete(s,1,1);
          delete(stringhold,1,1);
          termch := ' ';
          end
     else begin
          done := false;
          i := 1;
          while (i <= length(s)) and not done do
               begin
               if (s[i] in tch) then
                    begin
                    s1 := copy(s,1,i-1);
                    termch := s[i];
                    delete(s,1,i);
                    done := true;
                    end
               else inc(i);
               end;
          if not done then
               begin
               s1 := s;
               s := '';
               end;
          end;
     if stringhold > '' then
          DeTokenizeStrings(s,stringhold);
     NibbleString := s1;
     end;



{SECTION  RemoveBracketComments }
Function  RemoveBracketComments(var s : string; lchar,rchar : char) : boolean;
{ get rid of comments to prepare for parsing }
var i,j,k : integer;
    done  : boolean;
     begin
     done := true;
     if lchar <> chr(0) then
         begin
         if multilinecomment then
              begin  {looking for close}
              j := pos(rchar,s);
              if j > 0 then
                   begin
                   delete(s,1,j);
                   multilinecomment := false;
                   done := false;
                   end
              else s := '';   {still in multiline comment}
              end
         else begin  {looking for open comment }
              i := pos(lchar,s);
              if i > 0 then
                   begin
                   done := false;
                   j := pos(rchar,s);
                   if j > i then
                        begin
                        delete(s,i,(j-i)+1);
                        end
                   else begin
                        s := leftstr(s,i-1);
                        multilinecomment := true;
                        end;
                   end;
              end;
         end;
     RemoveBracketComments := done;
     end;


{SECTION  RemoveDelimitedString }
Procedure RemoveDelimitedString ( var s : string; lchr,rchr : char);
var s1 : string[1];
     begin
     s1 := GetDelimitedStr(s,lchr,rchr);
     end;



{SECTION  RemoveEOLComments }
Procedure RemoveEOLComments(var s : string; cchar : char);
{ get rid of comments to prepare for parsing }
var i : integer;
     begin
     if cchar <> chr(0) then
         begin
         i := pos(cchar,s);
         if i > 0 then
              begin
              s := leftstr(s,i-1);
              end;
         end;
     end;


{SECTION  ReplaceStringWithToken }
Function  ReplaceStringWithToken(var s,s1 : string; token : char) : boolean;
var notdone : boolean;
    i,j     : integer;
     begin
     notdone := false;
     s1 := '';
     i := pos(quotechar,s);
     if i > 0 then
          begin
          s[i] := token;
          j := pos(quotechar,s);
          if j > i then
              begin
              s1 := quotechar + copy(s,i+1,(j-i));
              delete(s,i+1,(j-i));
              notdone := true;
              end
          else s[i] := quotechar;   { mismatched quotes, put it back }
          if s[i] = chr(0) then delete(s,i,1);
          end;
     ReplaceStringWithToken := notdone;
     end;


{SECTION Rpos  }
Function Rpos(substr,str : string) : byte;
      {[STRING] equivalent to pos, but returns last occurance }
var i,j : integer;
    s : string;
     begin
     j := 0; i := 0;
     s := str;
     i := pos(substr,s);
     while i > 0 do
          begin
          j := i;      { j will have the position of the last match }
          s[i] := '~'; { so doesn't match again }
          i := pos(substr,s);
          end;
     Rpos := j;
     end;




{SECTION RScan  }
Function RScan(str : string; tch : char) : byte;
      {[STRING] finds LAST occurance of char TCH in string STR }
var i,j : integer;
     begin
     j := 0;
     for i := 1 to length(str) do if str[i] = tch then j := i;
     RScan := j;
     end;


{SECTION  ScanStufInit }
Procedure ScanStufInit;
     begin
     quotechar        := chr(34);   { double quote char }
     commenteolchar   := chr(33);   { exclamation point }
     commentpairLchar := chr(123);  { left squiggley bracket }
     commentpairRchar := chr(125);  { right squiggley bracket }
     qstringtoken     := chr(255);  { something unnatural in a string }
     multilinecomment := false;     {true while mismatched comment brackets}
     end;


{SECTION  ShiftUPString }
Procedure ShiftUPString(var s : string);
var done : boolean;
    stringhold : string;
     begin
     TokenizeStrings(s,stringhold);
     s := UpCaseStr(s);
     if stringhold > '' then DeTokenizeStrings(s,stringhold);
     end;


{SECTION  TokenizeStrings }
Procedure TokenizeStrings(var s,hold : string);
var i,j : integer;
    s1  : string;
     begin
     hold := '';
     while ReplaceStringWithToken(s,s1,qstringtoken) do hold := hold + s1;
     end;